home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / w3 / images.el.z / images.el
Encoding:
Text File  |  1998-05-21  |  7.8 KB  |  210 lines
  1. ;;; images.el --- Automatic image converters
  2. ;; Author: wmperry
  3. ;; Created: 1997/11/05 16:46:24
  4. ;; Version: 1.13
  5. ;; Keywords: images
  6.  
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;; Copyright (c) 1995 - 1996 by William M. Perry <wmperry@cs.indiana.edu>
  9. ;;; Copyright (c) 1996, 1997 Free Software Foundation Inc.
  10. ;;;
  11. ;;; This file is part of GNU Emacs.
  12. ;;;
  13. ;;; GNU Emacs is free software; you can redistribute it and/or modify
  14. ;;; it under the terms of the GNU General Public License as published by
  15. ;;; the Free Software Foundation; either version 2, or (at your option)
  16. ;;; any later version.
  17. ;;;
  18. ;;; GNU Emacs is distributed in the hope that it will be useful,
  19. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21. ;;; GNU General Public License for more details.
  22. ;;;
  23. ;;; You should have received a copy of the GNU General Public License
  24. ;;; along with GNU Emacs; see the file COPYING.  If not, write to the
  25. ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  26. ;;; Boston, MA 02111-1307, USA.
  27. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  28.  
  29. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  30. ;;; The emacsen compatibility package - load it up before anything else
  31. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  32. (require 'mule-sysdp)
  33.  
  34. (eval-and-compile
  35.   (if (not (and (string-match "XEmacs" emacs-version)
  36.         (or (> emacs-major-version 19)
  37.             (>= emacs-minor-version 14))))
  38.       (require 'w3-sysdp)))
  39.  
  40. (defvar image-temp-stack nil "Do no touch - internal storage.")
  41. (defvar image-converters nil "Storage for the image converters.")
  42. (defvar image-native-formats
  43.   (delq nil (cons (if (featurep 'x) 'xbm)
  44.           (mapcar (function (lambda (x) (if (featurep x) x)))
  45.               '(xpm gif jpeg tiff png imagick))))
  46.   "A list of image formats that this version of emacs supports natively.")
  47.  
  48. (defun image-register-converter (from to converter)
  49.   "Register the image converter for FROM to TO.  CONVERTER is the actual
  50. command used to convert the image.  If this is a string, it will be executed
  51. in a subprocess.  If a symbol, it is assumed to be a function.  It will be
  52. called with two arguments, the start and end of the data to be converted.
  53. The function should replace that data with the new image data.  The return
  54. value is not significant."
  55.   (let* ((node (assq from image-converters))
  56.      (replace (assq to (cdr-safe node))))
  57.     (cond
  58.      (replace                ; Replace existing converter
  59.       (setcdr replace converter)
  60.       (display-warning 'image (format "Replacing image converter %s->%s"
  61.                       from to)))
  62.      (node                ; Add to existing node
  63.       (setcdr node (cons (cons to converter) (cdr node))))
  64.      (t                    ; New toplevel converter
  65.       (setq image-converters (cons (cons from (list (cons to converter)))
  66.                    image-converters))))))
  67.  
  68. (defun image-unregister-converter (from to)
  69.   "Unregister the image converter for FROM to TO"
  70.   (let* ((node (assq from image-converters))
  71.      (tos (cdr-safe node))
  72.      (new nil))
  73.     (while tos
  74.       (if (eq to (car (car tos)))
  75.       nil
  76.     (setq new (cons (car tos) new)))
  77.       (setq tos (cdr tos)))
  78.     (setcdr node new)))
  79.  
  80. (defun image-converter-registered-p (from to)
  81.   (cdr-safe (assq to (cdr-safe (assq from image-converters)))))
  82.  
  83. (defun image-converter-chain (from to)
  84.   "Return the shortest converter chain for image format FROM to TO"
  85.   (setq image-temp-stack (cons from image-temp-stack))
  86.   (let ((converters (cdr-safe (assq from image-converters)))
  87.     (thisone nil)
  88.     (possibles nil)
  89.     (done nil))
  90.     (while (and (not done) converters)
  91.       (setq thisone  (car converters))
  92.       (cond
  93.        ((eq (car thisone) to)
  94.     (setq done t))
  95.        ((memq (car thisone) image-temp-stack)
  96.     nil)
  97.        (t
  98.     (setq possibles (cons (image-converter-chain (car thisone) to)
  99.                   possibles))))
  100.       (setq converters (cdr converters)))
  101.     (setq image-temp-stack (cdr image-temp-stack)
  102.       possibles (sort (delq nil possibles)
  103.               (function
  104.                (lambda (x y)
  105.                  (< (length (delete 'ignore x))
  106.                 (length (delete 'ignore y)))))))
  107.     (if (not done)
  108.     (setq done (car possibles)))
  109.     (cond
  110.      ((eq done t) (list (cdr thisone)))
  111.      (done (setq done (cons (cdr thisone) done)))
  112.      (t nil))))
  113.  
  114. (defun image-normalize (format data)
  115.   "Return an image specification for XEmacs 19.13 and later.  FORMAT specifies
  116. the image format, DATA is the image data as a string.  Any conversions to get
  117. to a suitable internal image format will be carried out."
  118.   (setq image-temp-stack nil)
  119.   (if (stringp format) (setq format (intern format)))
  120.   (if (not (memq format image-native-formats))
  121.       (let* ((winner (car-safe
  122.               (sort (mapcar
  123.                  (function
  124.                   (lambda (x)
  125.                 (cons x
  126.                       (delete 'ignore
  127.                           (image-converter-chain format
  128.                                      x)))))
  129.                     image-native-formats)
  130.                 (function
  131.                  (lambda (x y)
  132.                    (cond
  133.                 ((null (cdr x)) nil)
  134.                 ((= (length (cdr x))
  135.                     (length (cdr y)))
  136.                  (< (length (memq (car x)
  137.                           image-native-formats))
  138.                     (length (memq (car y)
  139.                           image-native-formats))))
  140.                 (t
  141.                  (< (length (cdr x))
  142.                     (length (cdr y))))))))))
  143.          (type (car-safe winner))
  144.          (chain (cdr-safe winner))
  145.          )
  146.     (if chain
  147.         (save-excursion
  148.           (set-buffer (generate-new-buffer " *image-conversion*"))
  149.           (erase-buffer)
  150.           (insert data)
  151.           (while chain
  152.         (cond
  153.          ((stringp (car chain))
  154.           (let ((file-coding-system mule-no-coding-system))
  155.             (call-process-region
  156.              (point-min) (point-max)
  157.              shell-file-name t
  158.              (list (current-buffer) nil)
  159.              shell-command-switch
  160.              (car chain))))
  161.          ((and (symbolp (car chain)) (fboundp (car chain)))
  162.           (funcall (car chain) (point-min) (point-max))))
  163.         (setq chain (cdr chain)))
  164.           (setq data (buffer-string))
  165.           (kill-buffer (current-buffer)))
  166.       (setq type format))
  167.     (vector type ':data data))
  168.     (vector format ':data data)))
  169.  
  170. (defun image-register-netpbm-utilities ()
  171.   "Register all the netpbm utility packages converters."
  172.   (interactive)
  173.   (if (image-converter-registered-p 'pgm 'pbm)
  174.       nil
  175.     (image-register-converter 'pgm 'pbm "pgmtopbm")
  176.     (image-register-converter 'ppm 'pgm "ppmtopgm")
  177.     (image-register-converter 'pnm 'xpm "ppmtoxpm")
  178.     (image-register-converter 'ppm 'xpm "ppmtoxpm)")
  179.     (image-register-converter 'xpm 'ppm "xpmtoppm")
  180.     (image-register-converter 'gif 'ppm "giftopnm")
  181.     (image-register-converter 'pnm 'gif "(ppmquant 256 | ppmtogif)")
  182.     (image-register-converter 'ppm 'gif "(ppmquant 256 | ppmtogif)")
  183.     (image-register-converter 'bmp 'ppm "bmptoppm")
  184.     (image-register-converter 'ppm 'bmp "ppmtobmp")
  185.     (image-register-converter 'ppm 'ps "pnmtops")
  186.     (image-register-converter 'pnm 'ps "pnmtops")
  187.     (image-register-converter 'ps 'pnm "pstopnm")
  188.     (image-register-converter 'g3  'pbm "g3topbm")
  189.     (image-register-converter 'macpt 'pbm "macptopbm")
  190.     (image-register-converter 'pbm 'macpt "pbmtomacp")
  191.     (image-register-converter 'pcx 'ppm "pcxtoppm")
  192.     (image-register-converter 'ppm 'pcx "ppmtopcx")
  193.     (image-register-converter 'pict 'ppm "picttoppm")
  194.     (image-register-converter 'ppm 'pict "ppmtopict")
  195.     (image-register-converter 'pnm 'sgi "pnmtosgi")
  196.     (image-register-converter 'tga 'ppm "tgatoppm")
  197.     (image-register-converter 'ppm 'tga "ppmtotga")
  198.     (image-register-converter 'sgi 'pnm "sgitopnm")
  199.     (image-register-converter 'tiff 'pnm "tifftopnm")
  200.     (image-register-converter 'pnm 'tiff "pnmtotiff")
  201.     (image-register-converter 'xbm 'pbm "xbmtopbm")
  202.     (image-register-converter 'pbm 'xbm "pbmtoxbm")
  203.     (image-register-converter 'png 'pnm "pngtopnm")
  204.     (image-register-converter 'pnm 'png "pnmtopng")
  205.     (image-register-converter 'pnm 'jbg "pbmtojbg")
  206.     (image-register-converter 'jbg 'pnm "jbgtopbm")
  207.     (image-register-converter 'jpeg 'ppm "djpeg")))
  208.    
  209. (provide 'images)
  210.